; ORIGINAL: 3dt2.1/examples/rbutl.scm
; $Id: rbutl.scm,v 1.4 1997/04/30 20:24:17 jread Exp $
;;=====================================================
; Purpose---
;    Define methods for creating solids using rubberb-banding
;;=====================================================

(provide 'rubber-band)

;;=====================================================
;; This procedure is used to get the positions used in the
;; rubberbanding procedures used in this file.  It can be changed
;; to do snapping while rubberbanding, etc.

(define RB:plane-pos (position 0 0 0))

(define (RB:get-position pe) (pick:position pe RB:plane-pos (gvector 0 0 1)))

;;=====================================================
;; RB:draw-figure is a helper procedure which is used to draw a "figure"
;; in a view.  See RB:create
(define (RB:draw-figure fig v)
  (view:set-rb-mode #t v)
  (for-each (lambda (p) (view:draw-polyline p v))  fig)
  (view:set-rb-mode #f v)
  )

;;=====================================================
;; RB:create is used to create a new scheme rubberband driver which displays
;; a "figure".  A "figure" is a list which contains either lists or vectors of
;; positions which can be used as arguments to view:draw-polyline to display
;; the figure.  A figure is displayed by calling view:draw-polyline on each
;; element of the list.
;; RB:create takes two arguments:
;;   figure      = the figure to draw
;;   update-proc = a procedure to update the positions in the figure.
;;                 it must take one argument which is a pick-event.  It uses the
;;                 pick-event to compute the new locations of the positions in
;;                 the figure.
(define RB:create
  (let ((View #f))
    (lambda (Figure update-proc)
      (let ((rb-hooks (make-vector 7 #f)))
        (vector-set! rb-hooks 1 (lambda (self pe)  ;; start ook
                                  (set! View (event:view pe))
                                  (update-proc pe)
                                  (RB:draw-figure Figure View)
                                  ))
        (vector-set! rb-hooks 2 (lambda (self pe)  ;; update hook
                                  (if View
                                      (begin
                                        (RB:draw-figure Figure View)
                                        (update-proc pe)
                                        (RB:draw-figure Figure View)
                                        ))))
        (vector-set! rb-hooks 3 (lambda (self)     ;; stop hook
                                  (RB:draw-figure Figure View)
                                  (set! View #f)
                                  ))
        (vector-set! rb-hooks 4 (lambda (self v)   ;; repaint hook
                                  (if (equal? v View) (RB:draw-figure Figure View))
                                  ))
        (vector-set! rb-hooks 6 (lambda (self)     ;;end hook
                                  (set! View #f)
                                  ))
        ;; Create the rubberband driver
        (rbd:scheme #f rb-hooks)
        ))))

;;=====================================================

(define PI 3.14159265358979323846)
(define TwoPI (* 2 PI))

;;=====================================================
;; Helper procedures

;; create a vector of positions and initialise the elements
(define (position-vector n pos)
  (let ((vec (make-vector n)))
    (let loop ((i 0)) (if (< i n) (begin (vector-set! vec i (position:copy pos)) (loop (+ i 1)))))
    vec
    ))

;; Get the number of distinct positions in a position vector.  If the first element eq? the last
;; element, then this is the vector-length - 1, else it is the vector-lenght.
(define (position-vector:length pv)
  (let* ((len (vector-length pv))
         (last (- len 1))
         )
    (if (eq? (vector-ref pv 0) (vector-ref pv last)) last len)
    ))

;; make a copy of a position-vector
(define (position-vector:copy pv)
  (let* ((n (vector-length pv))
         (vec (make-vector n))
         (np (position-vector:length pv))
         )
    (let loop ((i 0)) (if (< i np) (begin (vector-set! vec i (position:copy (vector-ref pv i))) (loop (+ i 1)))))
    (if (not (= n np)) (vector-set! vec np (vector-ref vec 0)))
    vec))

;; set the Z coordinate of all positions in a position vector to a new value
(define (position-vector:set-z! pv z)
  (let ((n (position-vector:length pv)))
    (let loop ((i 0)) (if (< i n) (begin (position:set-z! (vector-ref pv i) z) (loop (+ i 1)))))
    ))

;; Create an Ngon object
(define (ngon:create center nsides)
  (let* ((da (/ (* 2 PI) nsides))
         (cosda (cos da))
         (sinda (sin da))
         (xc (position:x center))
         (yc (position:y center))
         (zc (position:z center))
         (x0 (+ (* xc (- 1 cosda)) (* yc sinda)))
         (y0 (- (* yc (- 1 cosda)) (* xc sinda)))
         (update-proc (lambda (pts edge-pt)
                        (let loop ((i 0) (x (position:x edge-pt)) (y (position:y edge-pt)))
                          (if (<= i nsides)
                              (begin
                                (position:set! (vector-ref pts i) x y zc)
                                (loop (+ i 1)
                                      (+ x0 (* cosda x) (- (* sinda y)))
                                      (+ y0 (* sinda x) (* cosda y))
                                      )
                                )))))
         )
    (vector center  (position-vector (+ nsides 1) center)  update-proc)
    ))

;; get the center of an ngon
(define (ngon:center ngon) (vector-ref ngon 0))

;; get the position vector from an ngon
(define (ngon:positions ngon) (vector-ref ngon 1))

;; get the number of sides in an ngon
(define (ngon:nsides ngon) (- (vector-length (ngon:positions ngon)) 1))

;; update the positions in an ngon
(define (ngon:update ngon edge-pt)
  ((vector-ref  ngon 2) (vector-ref  ngon 1) edge-pt))

;;=====================================================
;; Create an n-gon Rubberband driver
(define (rb:ngon center nsides)
  (set! RB:plane-pos center) ;; this is a kludge
  (let ((ngon (ngon:create center nsides)))
    (RB:create (list (ngon:positions ngon)) ;; the figure
               (lambda (pe) ;; update-proc
                 (let ((pos (RB:get-position pe)))
                   (ngon:update ngon pos)
                   )))
    ))

;;=====================================================
;; This is just a test to see if I can update two different ngons
(define (rb:test center)
  (let ((ngon1 (ngon:create center 3))
        (ngon2 (ngon:create center 12))
        )
    (set! RB:plane-pos center) ;; this is a kludge
    (RB:create
      (list (ngon:positions ngon1) (ngon:positions ngon2))
      (lambda (pe) ;; update-proc
        (let ((pos (RB:get-position pe)))
          (ngon:update ngon1 pos)
          (ngon:update ngon2 pos)
          )))
    ))

;;=====================================================
;; Create a rubberband driver for rubberbanding a circle
(define (rb:circle center)
  (rb:ngon center 16)
  )

;;=====================================================
;; Create a rubberband driver for rubberbanding an extruded polygon.
;; The base polygon stays fixed.  The height of the second polygon
;; is changed.  You can optionally connect the vertices of the two polygons.
(define (rb:polygons base top connect)
  (RB:create
    (let ((n1 (vector-length base))
          (n2 (vector-length top))
          (np (position-vector:length base))
          )
      (cond
        ((eq? connect 'FIRST)
         (list base top (vector (vector-ref base 0) (vector-ref top 0)))
         )
        ((and (eq? connect 'ALL) (= n1 n2))
         (let loop ((i 0)
                    (fig (list base top))
                    )
           (if (< i np)
               (loop (+ i 1) (cons (vector (vector-ref base i) (vector-ref top i)) fig))
               fig
               )))
        (else (list base top))
        )) ;; This defines the figure

    (lambda (pe)  ;; update-proc
      (position-vector:set-z!
        top (position:z (pick:position pe (vector-ref base 0) (gvector 0 -1 0))))
      )
    ))

;;=====================================================
;; Rubberband a block
(define (rb:block p1 p2)
  (let ((pt2 (position (position:x p2) (position:y p2) (position:z p1))))
    (let ((base (vector
                  pt2
                  (position (position:x p1) (position:y p2) (position:z p1))
                  (position:copy p1)
                  (position (position:x p2) (position:y p1) (position:z p1))
                  pt2)))
      (rb:polygons base (position-vector:copy base) 'ALL)
      )))

;;=====================================================
;; Rubberband a cylinder
(define (rb:cylinder center radius)
  (let ((ngon (ngon:create center 16)))
    (ngon:update ngon (position:offset center (gvector radius 0 0)))
    (let ((base (ngon:positions ngon)))
      (rb:polygons base (position-vector:copy base) 'FIRST)
      )))

(define (rb:cone center r1 r2)
  (let ((base (ngon:create center 16))
        (top (ngon:create center 16))
        )
    (ngon:update base (position:offset center (gvector r1 0 0)))
    (ngon:update top (position:offset center (gvector r2 0 0)))
    (rb:polygons (ngon:positions base) (ngon:positions top) 'FIRST)
    ))

;;=====================================================
